home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist02.zoo / sources / xleval.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-11-09  |  20.1 KB  |  980 lines
  1. /* xleval - xlisp evaluator */
  2. /*        Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use        */
  5.  
  6. #include "xlisp.h"
  7. #include <string.h>
  8.  
  9. /* macro to check for lambda list keywords */
  10. #define iskey(s) ((s) == lk_optional \
  11.                || (s) == lk_rest \
  12.                || (s) == lk_key \
  13.                || (s) == lk_aux \
  14.                || (s) == lk_allow_other_keys)
  15.  
  16. /* macros to handle tracing */
  17. #define trenter(sym,argc,argv) {if (sym) doenter(sym,argc,argv);}
  18. #define trexit(sym,val) {if (sym) doexit(sym,val);}
  19.  
  20. /* external variables */
  21. extern LVAL xlenv,xlfenv,xldenv,xlvalue,true;
  22. extern LVAL lk_optional,lk_rest,lk_key,lk_aux,lk_allow_other_keys;
  23. extern LVAL s_evalhook,s_applyhook,s_tracelist;
  24. extern LVAL s_lambda,s_macro;
  25. extern LVAL s_unbound;
  26. extern int xlsample;
  27. extern char buf[];
  28.  
  29. /* local forward declarations */
  30. #ifdef ANSI
  31. VOID badarglist(void);
  32. VOID doenter(LVAL sym, int argc, LVAL *argv);
  33. VOID doexit(LVAL sym, LVAL val);
  34. LVAL evalhook(LVAL expr);
  35. LVAL evform(LVAL form);
  36. LVAL evfun(LVAL fun, int argc, LVAL *argv);
  37. int  evpushargs(LVAL fun,LVAL args);
  38. int  member(LVAL x, LVAL list);
  39. #ifdef APPLYHOOK
  40. LVAL applyhook(LVAL fun, LVAL args);
  41. #endif
  42. #else
  43. FORWARD VOID badarglist();
  44. FORWARD VOID doenter();
  45. FORWARD VOID doexit();
  46. FORWARD LVAL evalhook();
  47. FORWARD LVAL evform();
  48. FORWARD LVAL evfun();
  49. #ifdef APPLYHOOK
  50. FORWARD LVAL applyhook();
  51. #endif
  52. #endif
  53.  
  54. #ifdef ANSI
  55. static LVAL xlbadfunction(LVAL arg)
  56. #else
  57. LOCAL LVAL xlbadfunction(arg)
  58. LVAL arg;
  59. #endif
  60. {
  61.         return xlerror("bad function",arg);
  62. }
  63.  
  64. /* xleval - evaluate an xlisp expression (checking for *evalhook*) */
  65. LVAL xleval(expr)
  66.   LVAL expr;
  67. {
  68.     /* check for control codes */
  69.     if (--xlsample <= 0) {
  70.         xlsample = SAMPLE;
  71.         oscheck();
  72.     }
  73.  
  74.     /* check for *evalhook* */
  75.     if (getvalue(s_evalhook))
  76.         return (evalhook(expr));
  77.  
  78.     /* check for nil */
  79.     if (null(expr))
  80.         return (NIL);
  81.  
  82.     /* dispatch on the node type */
  83.     switch (ntype(expr)) {
  84.     case CONS:
  85.         return (evform(expr));
  86.     case SYMBOL:
  87.         return (xlgetvalue(expr));
  88.     default:
  89.         return (expr);
  90.     }
  91. }
  92.  
  93. /* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
  94. LVAL xlxeval(expr)
  95.   LVAL expr;
  96. {
  97.     /* check for nil */
  98.     if (null(expr))
  99.         return (NIL);
  100.  
  101.     /* dispatch on node type */
  102.     switch (ntype(expr)) {
  103.     case CONS:
  104.         return (evform(expr));
  105.     case SYMBOL:
  106.         return (xlgetvalue(expr));
  107.     default:
  108.         return (expr);
  109.     }
  110. }
  111.  
  112. /* xlapply - apply a function to arguments (already on the stack) */
  113. LVAL xlapply(argc)
  114.   int argc;
  115. {
  116.     LVAL fun,val;
  117.     
  118.     /* get the function */
  119.     fun = xlfp[1];
  120.  
  121.     /* get the functional value of symbols */
  122.     if (symbolp(fun)) {
  123.         while ((val = getfunction(fun)) == s_unbound)
  124.             xlfunbound(fun);
  125.         fun = xlfp[1] = val;
  126.     }
  127.  
  128.     /* check for nil */
  129.     if (null(fun))
  130.         xlbadfunction(fun);
  131.  
  132.     /* dispatch on node type */
  133.     switch (ntype(fun)) {
  134.     case SUBR: { 
  135.                 LVAL *oldargv;
  136.                 int oldargc;
  137.                 oldargc = xlargc;
  138.                 oldargv = xlargv;
  139.                 xlargc = argc;
  140.                 xlargv = xlfp + 3;
  141.                 val = (*getsubr(fun))();
  142.                 xlargc = oldargc;
  143.                 xlargv = oldargv;
  144.                 break;
  145.         }
  146.     case CONS:
  147.         if (!consp(cdr(fun)))
  148.             xlbadfunction(fun);
  149.         if (car(fun) == s_lambda)
  150.             fun =   xlfp[1]            /* TAA fix (vanNiekerk) */
  151.                 =    xlclose(NIL,
  152.                           s_lambda,
  153.                           car(cdr(fun)),
  154.                           cdr(cdr(fun)),
  155.                           xlenv,xlfenv);
  156.         else
  157.             xlbadfunction(fun);
  158.         /**** fall through into the next case ****/
  159.     case CLOSURE:
  160.         if (gettype(fun) != s_lambda)
  161.             xlbadfunction(fun);
  162.         val = evfun(fun,argc,xlfp+3);
  163.         break;
  164.     default:
  165.         xlbadfunction(fun);
  166.     }
  167.  
  168.     /* remove the call frame */
  169.     xlsp = xlfp;
  170.     xlfp = xlfp - (int)getfixnum(*xlfp);
  171.  
  172.     /* return the function value */
  173.     return (val);
  174. }
  175.  
  176. /* evform - evaluate a form */
  177. LOCAL LVAL evform(form)
  178.   LVAL form;
  179. {
  180.     LVAL fun,args,val;
  181.     LVAL tracing=NIL;
  182.     LVAL *argv;
  183.     int argc;
  184.  
  185.  
  186.     /* protect some pointers */
  187.     xlstkcheck(2);
  188.     xlsave(fun);
  189.     xlsave(args);
  190.  
  191.     /* get the function and the argument list */
  192.     fun = car(form);
  193.     args = cdr(form);
  194.  
  195.     /* get the functional value of symbols */
  196.     if (symbolp(fun)) {
  197.         if (getvalue(s_tracelist) && member(fun,getvalue(s_tracelist)))
  198.             tracing = fun;
  199.         fun = xlgetfunction(fun);
  200.     }
  201.  
  202.     /* check for nil */
  203.     if (null(fun))
  204.         xlbadfunction(NIL);
  205.  
  206.  
  207.     /* dispatch on node type */
  208.     switch (ntype(fun)) {
  209.     case SUBR:
  210. #ifdef APPLYHOOK
  211.         /* check for *applyhook* */
  212.         if (getvalue(s_applyhook)) {
  213.             val = (applyhook(fun,args));
  214.             break;
  215.         }
  216. #endif
  217.         argv = xlargv;
  218.         argc = xlargc;
  219.         xlargc = evpushargs(fun,args);
  220.         xlargv = xlfp + 3;
  221.         trenter(tracing,xlargc,xlargv);
  222.         val = (*getsubr(fun))();
  223.         trexit(tracing,val);
  224.         xlsp = xlfp;
  225.         xlfp = xlfp - (int)getfixnum(*xlfp);
  226.         xlargv = argv;
  227.         xlargc = argc;
  228.         break;
  229.     case FSUBR:
  230.         argv = xlargv;
  231.         argc = xlargc;
  232.         xlargc = pushargs(fun,args);
  233.         xlargv = xlfp + 3;
  234.         val = (*getsubr(fun))();
  235.         xlsp = xlfp;
  236.         xlfp = xlfp - (int)getfixnum(*xlfp);
  237.         xlargv = argv;
  238.         xlargc = argc;
  239.         break;
  240.     case CONS:
  241.         if (!consp(cdr(fun)))
  242.             xlbadfunction(fun);
  243.         if ((/* type = */ car(fun)) == s_lambda)
  244.             fun = xlclose(NIL,
  245.                           s_lambda,
  246.                           car(cdr(fun)),
  247.                           cdr(cdr(fun)),
  248.                           xlenv,xlfenv);
  249.         else
  250.             xlbadfunction(fun);
  251.         /**** fall through into the next case ****/
  252.     case CLOSURE:
  253.         if (gettype(fun) == s_lambda) {
  254. #ifdef APPLYHOOK
  255.             /* check for *applyhook* */
  256.             if (getvalue(s_applyhook)) {
  257.                 val = (applyhook(fun,args));
  258.                 break;
  259.             }
  260. #endif
  261.             argc = evpushargs(fun,args);
  262.             argv = xlfp + 3;
  263.             trenter(tracing,argc,argv);
  264.             val = evfun(fun,argc,argv);
  265.             trexit(tracing,val);
  266.             xlsp = xlfp;
  267.             xlfp = xlfp - (int)getfixnum(*xlfp);
  268.         }
  269.         else {
  270.             macroexpand(fun,args,&fun);
  271.             val = xleval(fun);
  272.         }
  273.         break;
  274.     default:
  275.         xlbadfunction(fun);
  276.     }
  277.  
  278.     /* restore the stack */
  279.     xlpopn(2);
  280.  
  281.     /* return the result value */
  282.     return (val);
  283. }
  284.  
  285. /* xlexpandmacros - expand macros in a form */
  286. LVAL xlexpandmacros(form)
  287.   LVAL form;
  288. {
  289.     LVAL fun,args;
  290.     
  291.     /* protect some pointers */
  292.     xlstkcheck(3);
  293.     xlprotect(form);
  294.     xlsave(fun);
  295.     xlsave(args);
  296.  
  297.     /* expand until the form isn't a macro call */
  298.     while (consp(form)) {
  299.         fun = car(form);                /* get the macro name */
  300.         args = cdr(form);                /* get the arguments */
  301.         if (!symbolp(fun) || !fboundp(fun))
  302.             break;
  303.         fun = xlgetfunction(fun);        /* get the expansion function */
  304.         if (!macroexpand(fun,args,&form))
  305.             break;
  306.     }
  307.  
  308.     /* restore the stack and return the expansion */
  309.     xlpopn(3);
  310.     return (form);
  311. }
  312.  
  313. /* macroexpand - expand a macro call */
  314. int macroexpand(fun,args,pval)
  315.   LVAL fun,args,*pval;
  316. {
  317.     LVAL *argv;
  318.     int argc;
  319.     
  320.     /* make sure it's really a macro call */
  321.     if (!closurep(fun) || gettype(fun) != s_macro)
  322.         return (FALSE);
  323.         
  324.     /* call the expansion function */
  325.     argc = pushargs(fun,args);
  326.     argv = xlfp + 3;
  327.     *pval = evfun(fun,argc,argv);
  328.     xlsp = xlfp;
  329.     xlfp = xlfp - (int)getfixnum(*xlfp);
  330.     return (TRUE);
  331. }
  332.  
  333. /* evalhook - call the evalhook function */
  334. LOCAL LVAL evalhook(expr)
  335.   LVAL expr;
  336. {
  337.     LVAL *newfp,olddenv,val;
  338.  
  339.     /* create the new call frame */
  340.     newfp = xlsp;
  341.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  342.     pusharg(getvalue(s_evalhook));
  343.     pusharg(cvfixnum((FIXTYPE)2));
  344.     pusharg(expr);
  345.     pusharg(cons(xlenv,xlfenv));
  346.     xlfp = newfp;
  347.  
  348.     /* rebind the hook functions to nil */
  349.     olddenv = xldenv;
  350.     xldbind(s_evalhook,NIL);
  351.     xldbind(s_applyhook,NIL);
  352.  
  353.     /* call the hook function */
  354.     val = xlapply(2);
  355.  
  356.     /* unbind the symbols */
  357.     xlunbind(olddenv);
  358.  
  359.     /* return the value */
  360.     return (val);
  361. }
  362.  
  363. #ifdef APPLYHOOK
  364. /* applyhook - call the applyhook function */
  365. LOCAL LVAL applyhook(fun,args)
  366.   LVAL fun,args;
  367. {
  368.     LVAL *newfp,olddenv,val,last,next;
  369.  
  370.     xlsave1(val);    /* protect against GC */
  371.  
  372.     if (consp(args)) { /* build argument list -- if there are any */
  373.         /* we will pass evaluated arguments, with hooks enabled */
  374.         /* so argument evaluation will be hooked too */
  375.         val = last = consa(xleval(car(args)));
  376.         args = cdr(args);
  377.         while (consp(args)) { /* handle any more in loop */
  378.             next = consa(xleval(car(args)));
  379.             rplacd(last,next);
  380.             last = next;
  381.             args = cdr(args);
  382.         }
  383.     }
  384.  
  385.     /* create the new call frame */
  386.     newfp = xlsp;
  387.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  388.     pusharg(getvalue(s_applyhook));
  389.     pusharg(cvfixnum((FIXTYPE)2));
  390.     pusharg(fun);
  391.     pusharg(val);
  392.     xlfp = newfp;
  393.  
  394.     /* rebind hook functions to NIL */
  395.  
  396.     olddenv = xldenv;
  397.     xldbind(s_evalhook,NIL);
  398.     xldbind(s_applyhook,NIL);
  399.  
  400.  
  401.     /* call the hook function */
  402.     val = xlapply(2);
  403.  
  404.     /* unbind the symbols */
  405.     xlunbind(olddenv);
  406.  
  407.     /* return the value */
  408.     return (val);
  409. }
  410. #endif
  411.  
  412. /* evpushargs - evaluate and push a list of arguments */
  413. LOCAL int evpushargs(fun,args)
  414.   LVAL fun,args;
  415. {
  416.     LVAL *newfp;
  417.     int argc;
  418.     
  419.     /* protect the argument list */
  420.     xlprot1(args);
  421.  
  422.     /* build a new argument stack frame */
  423.     newfp = xlsp;
  424.  
  425.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  426.     pusharg(fun);
  427.     pusharg(NIL); /* will be argc */
  428.  
  429.     /* evaluate and push each argument */
  430.     for (argc = 0; consp(args); args = cdr(args), ++argc)
  431.         pusharg(xleval(car(args)));
  432.  
  433.     /* establish the new stack frame */
  434.  
  435.     newfp[2] = cvfixnum((FIXTYPE)argc);
  436.     xlfp = newfp;
  437.     
  438.     /* restore the stack */
  439.     xlpop();
  440.  
  441.     /* return the number of arguments */
  442.     return (argc);
  443. }
  444.  
  445. /* pushargs - push a list of arguments */
  446. int pushargs(fun,args)
  447.   LVAL fun,args;
  448. {
  449.     LVAL *newfp;
  450.     int argc;
  451.     
  452.     /* build a new argument stack frame */
  453.     newfp = xlsp;
  454.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  455.     pusharg(fun);
  456.     pusharg(NIL); /* will be argc */
  457.  
  458.     /* push each argument */
  459.     for (argc = 0; consp(args); args = cdr(args), ++argc)
  460.         pusharg(car(args));
  461.  
  462.     /* establish the new stack frame */
  463.     newfp[2] = cvfixnum((FIXTYPE)argc);
  464.     xlfp = newfp;
  465.  
  466.     /* return the number of arguments */
  467.     return (argc);
  468. }
  469.  
  470. /* makearglist - make a list of the remaining arguments */
  471. LVAL makearglist(argc,argv)
  472.   int argc; LVAL *argv;
  473. {
  474.     LVAL list,this,last;
  475.     xlsave1(list);
  476.     for (last = NIL; --argc >= 0; last = this) {
  477.         this = cons(*argv++,NIL);
  478.         if (last) rplacd(last,this);
  479.         else list = this;
  480.         last = this;
  481.     }
  482.     xlpop();
  483.     return (list);
  484. }
  485.  
  486. #ifdef MSC6
  487. /* no optimization which interferes with setjmp */
  488. #pragma optimize("elg",off)
  489. #endif
  490.  
  491. /* evfun - evaluate a function */
  492. LOCAL LVAL evfun(fun,argc,argv)
  493.   LVAL fun; int argc; LVAL *argv;
  494. {
  495.     LVAL oldenv,oldfenv,cptr,val;
  496.     CONTEXT cntxt;
  497.  
  498.     /* protect some pointers */
  499.     xlstkcheck(3);
  500.     xlsave(oldenv);
  501.     xlsave(oldfenv);
  502.     xlsave(cptr);
  503.  
  504.     /* create a new environment frame */
  505.     oldenv = xlenv;
  506.     oldfenv = xlfenv;
  507.     xlenv = xlframe(getenvi(fun));
  508.     xlfenv = getfenv(fun);
  509.  
  510.     /* bind the formal parameters */
  511.     xlabind(fun,argc,argv);
  512.  
  513.     /* setup the implicit block */
  514.     if (getname(fun) != 0)
  515.         xlbegin(&cntxt,CF_RETURN,getname(fun));
  516.  
  517.     /* execute the block */
  518.     if (getname(fun) && setjmp(cntxt.c_jmpbuf))
  519.         val = xlvalue;
  520.     else
  521.         for (val = NIL, cptr = getbody(fun); consp(cptr); cptr = cdr(cptr)) {
  522.  
  523.                 /* check for control codes */
  524.                 if (--xlsample <= 0) {
  525.                         xlsample = SAMPLE;
  526.                         oscheck();
  527.                 }
  528.  
  529.                 val = car(cptr);
  530.  
  531.                 /* check for *evalhook* */
  532.                 if (getvalue(s_evalhook)) {
  533.                         val = evalhook(val);
  534.                         continue;
  535.                 }
  536.  
  537.                 /* check for nil */
  538.                 if (null(val)) {
  539.                         val = NIL;
  540.                         continue;
  541.                 }
  542.  
  543.                 /* dispatch on the node type */
  544.                 switch (ntype(val)) {
  545.                         case CONS:
  546.                                 val = evform(val);
  547.                                 break;
  548.                         case SYMBOL:
  549.                                 val = xlgetvalue(val);
  550.                                 break;
  551.                         default: /* nothing */
  552.                                 break;
  553.                 }
  554.         }
  555. /*                val = xleval(car(cptr)); */
  556.  
  557.     /* finish the block context */
  558.     if (getname(fun))
  559.         xlend(&cntxt);
  560.  
  561.     /* restore the environment */
  562.     xlenv = oldenv;
  563.     xlfenv = oldfenv;
  564.  
  565.     /* restore the stack */
  566.     xlpopn(3);
  567.  
  568.     /* return the result value */
  569.     return (val);
  570. }
  571.  
  572. #ifdef MSC6
  573. #pragma optimize("",on)
  574. #endif
  575.  
  576. /* xlclose - create a function closure */
  577. LVAL xlclose(name,type,fargs,body,env,fenv)
  578.   LVAL name,type,fargs,body,env,fenv;
  579. {
  580.     LVAL closure,key,arg,def,svar,new,last;
  581.     char keyname[STRMAX+2];
  582.  
  583.     /* protect some pointers */
  584.     xlsave1(closure);
  585.  
  586.     /* create the closure object */
  587.     closure = newclosure(name,type,env,fenv);
  588.     setlambda(closure,fargs);
  589.     setbody(closure,body);
  590.  
  591.     /* handle each required argument */
  592.     last = NIL;
  593.     while (consp(fargs) && ((arg = car(fargs)) !=0) && !iskey(arg)) {
  594.  
  595.         /* make sure the argument is a symbol */
  596.         if (!symbolp(arg))
  597.             badarglist();
  598.  
  599.         /* create a new argument list entry */
  600.         new = cons(arg,NIL);
  601.  
  602.         /* link it into the required argument list */
  603.         if (last)
  604.             rplacd(last,new);
  605.         else
  606.             setargs(closure,new);
  607.         last = new;
  608.  
  609.         /* move the formal argument list pointer ahead */
  610.         fargs = cdr(fargs);
  611.     }
  612.  
  613.     /* check for the '&optional' keyword */
  614.     if (consp(fargs) && car(fargs) == lk_optional) {
  615.         fargs = cdr(fargs);
  616.  
  617.         /* handle each optional argument */
  618.         last = NIL;
  619.         while (consp(fargs) && ((arg = car(fargs)) != 0) && !iskey(arg)) {
  620.  
  621.             /* get the default expression and specified-p variable */
  622.             def = svar = NIL;
  623.             if (consp(arg)) {
  624.                 if ((def = cdr(arg)) != 0)
  625.                     if (consp(def)) {
  626.                         if ((svar = cdr(def)) != 0)
  627.                             if (consp(svar)) {
  628.                                 svar = car(svar);
  629.                                 if (!symbolp(svar))
  630.                                     badarglist();
  631.                             }
  632.                             else
  633.                                 badarglist();
  634.                         def = car(def);
  635.                     }
  636.                     else
  637.                         badarglist();
  638.                 arg = car(arg);
  639.             }
  640.  
  641.             /* make sure the argument is a symbol */
  642.             if (!symbolp(arg))
  643.                 badarglist();
  644.  
  645.             /* create a fully expanded optional expression */
  646.             new = cons(cons(arg,cons(def,cons(svar,NIL))),NIL);
  647.  
  648.             /* link it into the optional argument list */
  649.             if (last)
  650.                 rplacd(last,new);
  651.             else
  652.                 setoargs(closure,new);
  653.             last = new;
  654.                 
  655.             /* move the formal argument list pointer ahead */
  656.             fargs = cdr(fargs);
  657.         }
  658.     }
  659.  
  660.     /* check for the '&rest' keyword */
  661.     if (consp(fargs) && car(fargs) == lk_rest) {
  662.         fargs = cdr(fargs);
  663.  
  664.         /* get the &rest argument */
  665.         if (consp(fargs) && ((arg = car(fargs)) != 0) && !iskey(arg) && symbolp(arg))
  666.             setrest(closure,arg);
  667.         else
  668.             badarglist();
  669.  
  670.         /* move the formal argument list pointer ahead */
  671.         fargs = cdr(fargs);
  672.     }
  673.  
  674.     /* check for the '&key' keyword */
  675.     if (consp(fargs) && car(fargs) == lk_key) {
  676.         fargs = cdr(fargs);
  677.  
  678.         /* handle each key argument */
  679.         last = NIL;
  680.         while (consp(fargs) && ((arg = car(fargs)) != 0) && !iskey(arg)) {
  681.  
  682.             /* get the default expression and specified-p variable */
  683.             def = svar = NIL;
  684.             if (consp(arg)) {
  685.                 if ((def = cdr(arg)) != 0)
  686.                     if (consp(def)) {
  687.                         if ((svar = cdr(def)) != 0)
  688.                             if (consp(svar)) {
  689.                                 svar = car(svar);
  690.                                 if (!symbolp(svar))
  691.                                     badarglist();
  692.                             }
  693.                             else
  694.                                 badarglist();
  695.                         def = car(def);
  696.                     }
  697.                     else
  698.                         badarglist();
  699.                 arg = car(arg);
  700.             }
  701.  
  702.             /* get the keyword and the variable */
  703.             if (consp(arg)) {
  704.                 key = car(arg);
  705.                 if (!symbolp(key))
  706.                     badarglist();
  707.                 if ((arg = cdr(arg)) != 0)
  708.                     if (consp(arg))
  709.                         arg = car(arg);
  710.                     else
  711.                         badarglist();
  712.             }
  713.             else if (symbolp(arg)) {
  714.                 strcpy(keyname,":");
  715.                 strcat(keyname,(char *)getstring(getpname(arg)));
  716.                 key = xlenter(keyname);
  717.             }
  718.  
  719.             /* make sure the argument is a symbol */
  720.             if (!symbolp(arg))
  721.                 badarglist();
  722.  
  723.             /* create a fully expanded key expression */
  724.             new = cons(cons(key,cons(arg,cons(def,cons(svar,NIL)))),NIL);
  725.  
  726.             /* link it into the optional argument list */
  727.             if (last)
  728.                 rplacd(last,new);
  729.             else
  730.                 setkargs(closure,new);
  731.             last = new;
  732.  
  733.             /* move the formal argument list pointer ahead */
  734.             fargs = cdr(fargs);
  735.         }
  736.     }
  737.  
  738.     /* check for the '&allow-other-keys' keyword */
  739.     if (consp(fargs) && car(fargs) == lk_allow_other_keys)
  740.         fargs = cdr(fargs);        /* this is the default anyway */
  741.  
  742.     /* check for the '&aux' keyword */
  743.     if (consp(fargs) && car(fargs) == lk_aux) {
  744.         fargs = cdr(fargs);
  745.  
  746.         /* handle each aux argument */
  747.         last = NIL;
  748.         while (consp(fargs) && ((arg = car(fargs)) != 0) && !iskey(arg)) {
  749.  
  750.             /* get the initial value */
  751.             def = NIL;
  752.             if (consp(arg)) {
  753.                 if ((def = cdr(arg)) != 0)
  754.                     if (consp(def))
  755.                         def = car(def);
  756.                     else
  757.                         badarglist();
  758.                 arg = car(arg);
  759.             }
  760.  
  761.             /* make sure the argument is a symbol */
  762.             if (!symbolp(arg))
  763.                 badarglist();
  764.  
  765.             /* create a fully expanded aux expression */
  766.             new = cons(cons(arg,cons(def,NIL)),NIL);
  767.  
  768.             /* link it into the aux argument list */
  769.             if (last)
  770.                 rplacd(last,new);
  771.             else
  772.                 setaargs(closure,new);
  773.             last = new;
  774.  
  775.             /* move the formal argument list pointer ahead */
  776.             fargs = cdr(fargs);
  777.         }
  778.     }
  779.  
  780.     /* make sure this is the end of the formal argument list */
  781.     if (fargs)
  782.         badarglist();
  783.  
  784.     /* restore the stack */
  785.     xlpop();
  786.  
  787.     /* return the new closure */
  788.     return (closure);
  789. }
  790.  
  791. /* xlabind - bind the arguments for a function */
  792. VOID xlabind(fun,argc,argv)
  793.   LVAL fun; int argc; LVAL *argv;
  794. {
  795.     LVAL *kargv,fargs,key,arg,def,svar,p;
  796.     int rargc,kargc;
  797.     
  798.     /* protect some pointers */
  799.     xlsave1(def);
  800.  
  801.     /* bind each required argument */
  802.     for (fargs = getargs(fun); fargs; fargs = cdr(fargs)) {
  803.  
  804.         /* make sure there is an actual argument */
  805.         if (--argc < 0)
  806.             xlfail("too few arguments");
  807.  
  808.         /* bind the formal variable to the argument value */
  809.         xlbind(car(fargs),*argv++);
  810.     }
  811.  
  812.     /* bind each optional argument */
  813.     for (fargs = getoargs(fun); fargs; fargs = cdr(fargs)) {
  814.  
  815.         /* get argument, default and specified-p variable */
  816.         p = car(fargs);
  817.         arg = car(p); p = cdr(p);
  818.         def = car(p); p = cdr(p);
  819.         svar = car(p);
  820.  
  821.         /* bind the formal variable to the argument value */
  822.         if (--argc >= 0) {
  823.             xlbind(arg,*argv++);
  824.             if (svar) xlbind(svar,true);
  825.         }
  826.  
  827.         /* bind the formal variable to the default value */
  828.         else {
  829.             if (def) def = xleval(def);
  830.             xlbind(arg,def);
  831.             if (svar) xlbind(svar,NIL);
  832.         }
  833.     }
  834.  
  835.     /* save the count of the &rest of the argument list */
  836.     rargc = argc;
  837.     
  838.     /* handle '&rest' argument */
  839.     if ((arg = getrest(fun)) != 0) {
  840.         def = makearglist(argc,argv);
  841.         xlbind(arg,def);
  842.         argc = 0;
  843.     }
  844.  
  845.     /* handle '&key' arguments */
  846.     if ((fargs = getkargs(fun)) != 0) {
  847.         for (; fargs; fargs = cdr(fargs)) {
  848.  
  849.             /* get keyword, argument, default and specified-p variable */
  850.             p = car(fargs);
  851.             key = car(p); p = cdr(p);
  852.             arg = car(p); p = cdr(p);
  853.             def = car(p); p = cdr(p);
  854.             svar = car(p);
  855.  
  856.             /* look for the keyword in the actual argument list */
  857.             for (kargv = argv, kargc = rargc; (kargc -= 2) >= 0; kargv += 2)
  858.                 if (*kargv == key)
  859.                     break;
  860.  
  861.             /* bind the formal variable to the argument value */
  862.             if (kargc >= 0) {
  863.                 xlbind(arg,*++kargv);
  864.                 if (svar) xlbind(svar,true);
  865.             }
  866.  
  867.             /* bind the formal variable to the default value */
  868.             else {
  869.                 if (def) def = xleval(def);
  870.                 xlbind(arg,def);
  871.                 if (svar) xlbind(svar,NIL);
  872.             }
  873.         }
  874.         argc = 0;
  875.     }
  876.  
  877.     /* check for the '&aux' keyword */
  878.     for (fargs = getaargs(fun); fargs; fargs = cdr(fargs)) {
  879.  
  880.         /* get argument and default */
  881.         p = car(fargs);
  882.         arg = car(p); p = cdr(p);
  883.         def = car(p);
  884.  
  885.         /* bind the auxiliary variable to the initial value */
  886.         if (def) def = xleval(def);
  887.         xlbind(arg,def);
  888.     }
  889.  
  890.     /* make sure there aren't too many arguments */
  891.     if (argc > 0)
  892.         xlfail("too many arguments");
  893.  
  894.     /* restore the stack */
  895.     xlpop();
  896. }
  897.  
  898. /* doenter - print trace information on function entry */
  899. LOCAL VOID doenter(sym,argc,argv)
  900.   LVAL sym; int argc; LVAL *argv;
  901. {
  902.     extern int xltrcindent;
  903.     int i;
  904.     
  905.     /* indent to the current trace level */
  906.     for (i = 0; i < xltrcindent; ++i)
  907.         trcputstr(" ");
  908.     ++xltrcindent;
  909.  
  910.     /* display the function call */
  911.     sprintf(buf,"Entering: %s, Argument list: (",getstring(getpname(sym)));
  912.     trcputstr(buf);
  913.     while (--argc >= 0) {
  914.         trcprin1(*argv++);
  915.         if (argc) trcputstr(" ");
  916.     }
  917.     trcputstr(")\n");
  918. }
  919.  
  920. /* doexit - print trace information for function/macro exit */
  921. LOCAL VOID doexit(sym,val)
  922.   LVAL sym,val;
  923. {
  924.     extern int xltrcindent;
  925.     int i;
  926.     
  927.     /* indent to the current trace level */
  928.     --xltrcindent;
  929.     for (i = 0; i < xltrcindent; ++i)
  930.         trcputstr(" ");
  931.     
  932.     /* display the function value */
  933.     sprintf(buf,"Exiting: %s, Value: ",getstring(getpname(sym)));
  934.     trcputstr(buf);
  935.     trcprin1(val);
  936.     trcputstr("\n");
  937. }
  938.  
  939. /* member - is 'x' a member of 'list'? */
  940. LOCAL int member(x,list)
  941.   LVAL x,list;
  942. {
  943.     for (; consp(list); list = cdr(list))
  944.         if (x == car(list))
  945.             return (TRUE);
  946.     return (FALSE);
  947. }
  948.  
  949. /* xlunbound - signal an unbound variable error */
  950. VOID xlunbound(sym)
  951.   LVAL sym;
  952. {
  953.     xlcerror("try evaluating symbol again","unbound variable",sym);
  954. }
  955.  
  956. /* xlfunbound - signal an unbound function error */
  957. VOID xlfunbound(sym)
  958.   LVAL sym;
  959. {
  960.     xlcerror("try evaluating symbol again","unbound function",sym);
  961. }
  962.  
  963. /* xlstkoverflow - signal a stack overflow error */
  964. VOID xlstkoverflow()
  965. {
  966.     xlabort("evaluation stack overflow");
  967. }
  968.  
  969. /* xlargstkoverflow - signal an argument stack overflow error */
  970. VOID xlargstkoverflow()
  971. {
  972.     xlabort("argument stack overflow");
  973. }
  974.  
  975. /* badarglist - report a bad argument list error */
  976. LOCAL VOID badarglist()
  977. {
  978.     xlfail("bad formal argument list");
  979. }
  980.